home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / TPAINT2.LZH / VUTPAINT.PAS < prev   
Pascal/Delphi Source File  |  1986-03-15  |  4KB  |  116 lines
  1.  
  2.  
  3.        (* ******************************************************* *)
  4.        (*                                                         *)
  5.        (*                     VUTPAINT.PAS                        *)
  6.        (*                                                         *)
  7.        (*    This is a program to view picture files created by   *)
  8.        (*    Turbo Paint (TPAINT.COM) with out any menu screen    *)
  9.        (*    or border. It also shows you how to call paint       *)
  10.        (*    pictures into your Turbo programs                    *)
  11.        (*                                                         *)
  12.        (*    (c) March 1986    Donald L. Pavia                    *)
  13.        (*                      Department of Chemistry            *)
  14.        (*                      Western Washington University      *)
  15.        (*                      Bellingham, WA 98225               *)
  16.        (*                                                         *)
  17.        (* ******************************************************* *)
  18.  
  19.  
  20. program ViewTPaint (input,output);
  21.  
  22. const ColBuffer = $B800; Offset = 0;
  23.       Blank = ' '; IOerr : boolean = false;
  24. type
  25.       str14 = string[14];
  26.       ScreenType = array[0..16383] of byte;
  27.       ScreenPointer = ^ScreenType;
  28. var   ViewAnother : char;
  29.       PicName : str14;
  30.       i,col,pal : integer;
  31. {------------------------------------------------}
  32. procedure IOcheck (IOresult : integer; var IOerr : boolean);
  33.  
  34. begin
  35.      IOerr := (IOresult <> 0);
  36.      if IOerr then begin write (#7); write (Blank) end;
  37. end;
  38. {------------------------------------------------}
  39. function Exist (FileName : Str14) : boolean;
  40.  
  41. var  Fil : file;
  42.  
  43. begin
  44.      assign (Fil,FileName);
  45.      {$I-} reset (Fil); {$I+}
  46.      Exist := (IOresult = 0);
  47.      close (Fil);
  48. end;
  49. {------------------------------------------------}
  50. procedure LoadScreen(FileName : str14);
  51.  
  52.   type PicFile = file of ScreenType;
  53.  
  54.   var  Picture : ScreenPointer;
  55.        PictureFile : PicFile;
  56.  
  57.   begin
  58.        Picture := ptr (ColBuffer,Offset);
  59.        assign (PictureFile,FileName);
  60.        reset (PictureFile);
  61.        read (PictureFile,picture^);
  62.        close (PictureFile);
  63.   end;
  64.  
  65. {------------------------------------------------}
  66.  
  67. begin
  68.      repeat
  69.        clrscr;
  70.        writeln; writeln;
  71.        write   (' Enter FileName : ');
  72.        readln (PicName);
  73.        writeln;
  74.        write   (' The Screen Mode is Medium Resolution ');
  75.        writeln; writeln;
  76.        write   (' Choice of BackGroundColor (0..15) ? :  ');
  77.   {$I-}
  78.        repeat
  79.             read (col); IOcheck (IOresult,IOerr);
  80.        until not IOerr;
  81.  
  82.        writeln; writeln;
  83.        write   (' Choice of Palette (0..3) ? :  ');
  84.  
  85.        repeat
  86.             read (pal); IOcheck (IOresult,IOerr);
  87.        until not IOerr;
  88.   {$I+}
  89.        writeln; writeln; writeln;
  90.        writeln (' Just Press <RETURN> to View Screen !!!!!!  ');
  91.        writeln;
  92.        write   (' Then Press <RETURN> a Second Time to Exit ');
  93.        readln;
  94.        GraphColorMode; GraphBackGround (col); Palette (pal);
  95.  
  96.        if Exist (PicName) then
  97.             LoadScreen (PicName)
  98.        else
  99.           begin
  100.                  gotoxy (5,12); write ('Sorry, That File Doesn''t Exist');
  101.                  gotoxy (5,14); write ('  Press <RETURN> to Continue ')
  102.           end;
  103.        readln;
  104.        TextMode (c80); clrscr;
  105.        writeln;
  106.        write (' View Another? Y/N ?  ');
  107.        repeat
  108.             read (Kbd,ViewAnother);
  109.        until UpCase(ViewAnother) in ['Y','N'];
  110.        writeln;writeln;
  111.  
  112.      until UpCase(ViewAnother) = 'N';
  113.  
  114. end.
  115.  
  116.